perm filename BMSTF.F4[XX,LCS] blob sn#207650 filedate 1976-03-24 generic text, type T, neo UTF8
00100	C**** BMSTF, BMS, METER, RNOTE, MAKNUM, IABS, DRWNT, RHORZ, RDRAW
00200	C  ********** WHOLE & HALF RESTS, BEAMS ******
00300		SUBROUTINE BMSTF
00400		IMPLICIT INTEGER(A-Q,S-Z)
00500		REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1
00600		COMMON/STF/RSTFAC(-3/4),RSTJ2/MIN/MINI,RMINI
00700		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
00800		COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
00900		COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
01000		1 RJA,YY,DISX,HGT,RZ,INP(53)
01100		EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
01200		1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01300		1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1))
01400		1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8)),(RX3,RJQ(20))
01500		DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
01600	C  RDBR IS SPACER FOR DBL BAR.
01700	C  RTF COMPENSATES FOR BAD PLANNING.
01710		IF(JA.NE.8)GO TO 100
01720		CALL STAFF
01730		RETURN
01800	100	RST7=RSTJ2*7.
01900		RST18=RSTJ2*18.
02000	C  TO COMPENSATE FOR NOTE #3 COMING AT POS=0
02100	
02200		R3Q=R3
02400	C  NEXT IS FOR BEAMS
02500		RMINI=RSTJ2
02600		RX=2.7*RSTJ2*5.96
02700	C******************************
02800		R6=RHORZ(R6)
02900		IF(R8.NE.0)GO TO 204
03000		IF(R10.GE.10)GO TO 204
03100		IF(J7)GO TO 204
03200		IF(R9.NE.0)GO TO 1
03300	C  R8=0 AND R9=NUM  -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLETS, ETC.)
03400	204	IF(R9.NE.0)R9=RHORZ(R9)
03500		IF(J7)GO TO 201
03600	200	IF(J10.LT.10)GO TO 91
03700	C NEXT FOR INNER, PARTIAL BEAMS
03800		R8=RHORZ(R8)
03900		R10=AMOD(R10,10.)
04000		GO TO(2,3,4),J10/10
04100	2	RH=R9+RX
04200		GO TO 1
04300	3	R8=R9-RX
04400	C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
04500	4	RH=R8
04600	C  LEFT INNER POS.
04700		GO TO 1
04800	201	J7=-J7
04900	C P8=WIDTH OF TREM. P9=0(SANS OTHER BEAMS) OR =POS.3, P10=DISP.
05000		CALL NOZERO(R10)
05100	C  ALWAYS AT LEAST 1 IN DISPLACEMENT
05200		J10=30
05300	C TO ACTIVATE PARTIAL BEAM SECTION
05400		IF(J9.NE.0)GO TO 202
05500	C  NEXT FOR TREM. WITHOUT OTHER BEAMS.
05600		RH=-1
05700		IF(J7.GE.20)RH=-RH
05800	CC203	R4=R4+R10*RH
05900	CC	CALL CENTX
06000		R5=R4+RH
06100		R9=R3
06200		R6=R3+22.*RMINI
06300	202	IF(R8.EQ.0)R8=4. 
06400		RX=R8*RMINI*2.98
06500		RH=R9+RX
06600		R9=R9-RX
06700		GO TO 1
06800	
06900	91	IF(J8.EQ.0)GO TO 1
07000		IF(J8.GT.0)GO TO 92
07100	C FOR J8=-(10+DN) OR -(20+DN)
07200		R9=R3+RX
07300		IF(J8.LE.-20)R9=R6-RX
07400	192	J8=-J8
07500	92	IF(J10.EQ.0)J10=MOD(J8,10)
07600	CC??? 4/75	J8=J8-J10
07700		IF(J10.EQ.0)J10=1
07800		R10=J10
07900	C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
08000	1	IF(IABS(J4).LT.100)GO TO 97
08100		RMINI=.6*RSTJ2
08200		R5=AMOD(R5,100.0)
08300	C   SPACE BETWEEN BEAMS
08400	97	RJ=RMINI*11.
08500		RW=RMINI*RHGT
08600	C  DIST. UP OR DOWN FROM NOTE HEAD.
08700		RJA=R10*RJ
08800	C  DISPLACEMENT
08900		RD=R9
09000	C  POSITION 3
09100		RJX=CENTR-RW+RJA
09200	C  FINAL HEIGHT OF LEFT SIDE
09300	C  NEG R7=TREMOLO
09400		RX=MOD(J7,10)
09500		JJ2=J7-20
09600		RA=R6
09700	C  HORIZANTAL DIST.
09800		RJY=R5*RST7+POS-RST18-RW+RJA
09900	C   VERTICAL POS OF RIGHT SIDE.
10000		RW=R14*RMINI
10100		RY=1.
10200		IF(J7.GE.20)GO TO 98 
10300	C JUMP IF STEMS ARE DOWN
10400		RY=-RY
10500	C  FOR  THICKENING INCR.
10600		JJ2=J7-10
10700		RJ=-RJ
10800		RJA=RMINI*R2HGT-2.*RJA
10900		RJX=RJX+RJA
11000		RJY=RJY+RJA
11100		R3Q=R3Q+RW
11200	C  POSITION 1
11300		RA=RA+RW
11400	C  POSITION 2
11500		RD=RD+RW
11600	C******************************
11700		RH=RH+RW
11800	98	RSTJ2=RSTJ2*RBM
11900	C  RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
12000	93	IF(JJ2.GT.RX)GO TO 94
12100		IF(J10.GE.10)GO TO 7
12200	C**********************
12300		IF(J8.EQ.0)GO TO 94
12400		R3=RW
12500		IF(J9.EQ.0)GO TO 292
12600	 	IF(J8.GE.20)GO TO 193
12700	293	RX=R3Q-RD
12800		GO TO 194
12900	7	RHX=RH-R3Q
13000		R3=RD-R3Q
13100		GO TO 292
13200	193	RX=RD-RA
13300	194	R3=ABS(RX)
13400	292	DISX=ABS(R3Q-RA)
13500		HGT=RJX-RJY
13600		IF(J10.GE.10)HGT1=HGT*RHX/DISX
13700	C**********************
13800		R3=R3/DISX
13900	195	HGT=HGT*R3
14000	196	L=J8/10
14100		J8=0
14200		IF(J10.GE.10)GO TO 8
14300	C***************
14400		IF(L.EQ.1)GO TO 95
14500	C   BEAM LFT=1,  RT=2   (PARAM 8=10 OR 20)
14600		R3Q=RD
14700		RJX=RJY+HGT
14800		GO TO 94
14900	C**************
15000	8	R3Q=RH
15100		RA=RD
15200		RJY=RJX-HGT
15300		RJX=RJX-HGT1
15400		GO TO 94
15500	95	RA=RD
15600		RJY=RJX-HGT
15700	94	L=7.*RMINI
15800	930	RC=0
15900	C  MINI LINES HAVE .2 SMALLER BEAMS.  MAYBE CHANGE THIS??
16000		CALL LINES(R3Q,RJX,3)
16100		DO 941 K=1,L
16200		CALL BMS
16300		IF(PLT.GE.0)GO TO 940
16400		RC=RC+RY
16500	C FOR THICKENING.
16600		CALL BMS
16700		CALL EXCH(RA,R3Q)
16800	941	CALL EXCH(RJY,RJX)
16900		CALL BMS
17000	C  DRAWS 5 LINES FOR BEAMS.
17100	940	JJ2=JJ2-1
17200		IF(JJ2.LE.0)GO TO 942
17300	C  IF P7=10 OR 20 ONE BEAM WILL APPEAR.
17400		RJY=RJY+RJ
17500		RJX=RJX+RJ
17600		GO TO 930
17700	
17800	942	IF(R8.NE.0)RETURN
17900		IF(R9.EQ.0)RETURN
18000		IF(R10.GE.30)RETURN
18100	C FOR NUMBERS OUTSIDE BEAMS
18200		RSTJ2=RMINI
18300		RD=-10.
18400		IF(R7.LT.20)RD=8.3
18500	943	J3=R3Q+(RA-R3Q)/2.
18600		R6=1.
18700	CC *** DONE IN CENTX ***	R4=AMOD(R4,100.)
18800		R4=R4+(R5-R4)/2.+RD
18900		R7=1
19000	C ITALICS
19100		CALL MAKNUM(R9)
19300		END